;;  Copyright (c) Jeffrey Straszheim. All rights reserved.  The use and
;;  distribution terms for this software are covered by the Eclipse Public
;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
;;  be found in the file epl-v10.html at the root of this distribution.  By
;;  using this software in any fashion, you are agreeing to be bound by the
;;  terms of this license.  You must not remove this notice, or any other,
;;  from this software.
;;
;;  rules.clj
;;
;;  A Clojure implementation of Datalog -- Rules Engine
;;
;;  straszheimjeffrey (gmail)
;;  Created 2 Feburary 2009


(ns clojure.datalog.rules
  (:use clojure.datalog.util)
  (:use clojure.contrib.def)
  (:use [clojure.set :only (union intersection difference)])
  (:use [clojure.contrib.seq-utils :only (separate)])
  (:use [clojure.contrib.except :only (throwf)]))

;;; Rules

(defstruct rule
  :head           ; The head predicate
  :body)          ; A collection of body predicates


;;; Predicates

(defstruct predicate
  :relation       ; The relation this term queries over
  :terms          ; A hash of term names to variables/values
  :negated)       ; Is this a negated predicate?

(def negation-symbol 'not!)


;;; Rule Queries

(defn display-logic-predicate
  "Flattens a predicate for display"
  [predicate]
  (let [atom (conj (apply concat (:terms predicate)) (:relation predicate))]
    (if (:negated predicate)
      (conj atom negation-symbol)
      atom)))

(defn display-logic-rule
  "Flattens a rule for display"
  [rule]
  (let [body (map display-logic-predicate (:body rule))]
    (list* 'logic-rule (display-logic-predicate (:head rule)) '- body)))

(defn predicate-vars
  "Return a set of variables found in a predicate"
  [pred]
  (set (filter is-var? (-> pred :terms vals))))

(defn body-vars
  "Returns all the non-negated vars in the body"
  [rule]
  (reduce union #{} (map predicate-vars (remove :negated (:body rule)))))

(defn negated-vars
  "Returns all the negated vars in the body"
  [rule]
  (reduce union #{} (map predicate-vars (filter :negated (:body rule)))))

(defn- all-vars-found?
  "Are all the vars in the head found in the (positive) body?"
  [rule]
  (let [head-vars (-> rule :head predicate-vars)]
    (= head-vars (intersection head-vars (body-vars rule)))))

(defn- negation-safe?
  "Are all negation vars found in positive relations?"
  [rule]
  (empty? (difference (negated-vars rule) (body-vars rule))))

(defn rule-safe?
  "Is a rule safe?  This guarantees that infinite matialization cannot
   occur due to negated rules or unbound predicates.  Throws an
   exception for an unsafe rule."
  [rule]
  (when-not (all-vars-found? rule)
    (throwf "Rule %s has unrealized variables in its head" (display-logic-rule rule)))
  (when-not (negation-safe? rule)
    (throwf "Rule %s has unsafe negation" (display-logic-rule rule)))
  rule)

(defn rule-relation
  "The relation defined by this rule"
  [rule]
  (-> rule :head :relation))

(defn rule-dependent-relations
  "The relations on which this rule depends"
  [rule]
  (set (map :relation (:body rule))))

(defn rule-dependent-relations-positive
  "The relations on which this rule depends in a positive manner."
  [rule]
  (set (map :relation (remove :negated (:body rule)))))

(defn rule-dependent-relations-negative
  "The relations on which this rule depends in a negative manner."
  [rule]
  (set (map :relation (filter :negated (:body rule)))))

;;; Rule Builder

(defmacro logic-predicate
  "Builds a predicate"
  [& args]
  (let [negated (= (first args) negation-symbol)
        atom (if (= (first args) negation-symbol)
               (rest args)
               args)
        relation (first atom)
        terms (rest atom)
        wrap-var (fn [arg] (if (is-var? arg) `(quote ~arg) arg))
        wrapped-terms (map wrap-var terms)
        content `(struct predicate ~relation (hash-map ~@wrapped-terms))]
    (if negated
      `(assoc ~content :negated true)
      content)))

(defmacro logic-rule
  "Builds a rule"
  [head dash & body]
  (assert (= dash '-))
  (let [head-form `(logic-predicate ~@head)
        body-forms (map (fn [predicate] `(logic-predicate ~@predicate)) body)]
    `(let [rule# (struct rule ~head-form (list ~@body-forms))]
       (rule-safe? rule#))))

;;; Match predicate

(defn- extend-bindings
  "Bind a var to the bindee if possible.  Return the new bindings, or
  nil if the variable was already bound, and the match failed."
  [bindings var bindee]
  (if (contains? bindings var)
    (let [curval (bindings var)]
      (if (= curval bindee) bindings nil))
    (assoc bindings var bindee)))

(defn- match-term
  "Match the binder to the bindee, extending bindings if necessary.
   If the match succeeds, return the new bindings.  If the match
   fails, return nil."
  [bindings binder bindee]
  (when bindings
    (cond
     (is-var? binder) (extend-bindings bindings binder bindee)
     :otherwise (when (= binder bindee) bindings))))

(defn- match-atom
  "Match the terms to one binding and one tuple.  Returns a new
   bindings or nil."
  [terms bindings entity]
  (let [match (fn [bind [name val]]
                (match-term bind val (get entity name)))]
  (reduce match bindings terms)))

(defn- match-predicate
  "Match a predicate against a (materialized) relation.  A stream of
   prior bindings must be provided.  This will return a stream of new
   bindings."
  [predicate bindings-stream relation]
  (let [terms (:terms predicate)]
    (filter identity
            (for [bindings bindings-stream
                  entity relation]
              (match-atom terms bindings entity)))))

(defn- match-predicate-negated
  "Filters out bindings in the stream where predicate matches the
   relation."
  [predicate bindings-stream relation]
  (let [terms (:terms predicate)]
    (filter identity
            (for [bindings bindings-stream]
              (let [match? (some (partial match-atom terms bindings) relation)]
                (if match? nil bindings))))))
    
       
;;; Match a Rule

(defn- realize-bindings
  "Given a hash of keys to binding vars, and a bindings, replace the
   vars in the hash with the value of the vars."
  [hash bindings]
  (map-values
   (fn [val] (if (is-var? val) (get bindings val) val))
   hash))


(defn match-rule
  "Matches a rule against the content of a database, returning a
   database with a single relation."
  [rule database]
  (let [[negated positive] (separate :negated (:body rule))
        step (fn [match-f bindings-stream predicate]
               (match-f
                predicate
                bindings-stream
                (database (:relation predicate))))
        bindings-stream+ (reduce (partial step match-predicate)
                                 [{}]
                                 positive)
        bindings-stream (reduce (partial step match-predicate-negated)
                                bindings-stream+
                                negated)
        records (set (map
                      (partial realize-bindings (-> rule :head :terms))
                      bindings-stream))]
    {(rule-relation rule) records}))



(comment

;; A database is a hash of named relations.

;; A relation is a set of hashs, as in the standard Clojure set library.

(def database {
               :users
               #{
                 { :name "Mary"  :age 32 :department 1 }
                 { :name "Sally" :age 24 :department 1 }
                 { :name "Bob"   :age 55 :department 2 }}

               :departments
               #{
                 { :id 1 :name "Accounting"  :location "3rd floor" }
                 { :id 2 :name "Programming" :location "2nd floor" }}})

(def rule-1 (logic-rule (:employee-department :employee-name ?employee-name
                                                :department-name ?department-name)
                          -
                          (:users :name ?employee-name :department ?department-id)
                          (:departments :name ?department-name :id ?department-id)))
                          

(display-logic-rule rule-1)
(rule-safe? rule-1)
(rule-safe? (logic-rule (:a :a ?x :b ?y) - (:c :x ?x) (:d :fred :fred)))
(rule-safe? (logic-rule (:a :a ?x :b ?y) - (:c :x ?x) (:d :b ?y) (not! :e :b ?y)))
(rule-safe? (logic-rule (:a :a ?x :b ?y) - (:c :x ?x) (:d :b ?y) (not! :e :b ?q)))
(rule-relation rule-1)
(rule-dependent-relations rule-1)
(match-rule rule-1 database)

(def rule-2 (logic-rule (:employee-department :employee-name ?employee-name
                                                :department-name ?department-name)
                          -
                          (:users :name ?employee-name :department ?department-id)
                          (:departments :name ?department-name :id ?department-id)
                          (not! :users :name ?employee-name :age 32)))

(match-rule rule-2 database)

)


;; End of file